home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / Carp / Heavy.pm
Encoding:
Perl POD Document  |  2009-06-26  |  8.0 KB  |  298 lines
  1. # Carp::Heavy uses some variables in common with Carp.
  2. package Carp;
  3.  
  4. # On one line so MakeMaker will see it.
  5. use Carp;  our $VERSION = $Carp::VERSION;
  6. # use strict; # not yet
  7.  
  8. # 'use Carp' just installs some very lightweight stubs; the first time
  9. # these are called, they require Carp::Heavy which installs the real
  10. # routines.
  11.  
  12. # The members of %Internal are packages that are internal to perl.
  13. # Carp will not report errors from within these packages if it
  14. # can.  The members of %CarpInternal are internal to Perl's warning
  15. # system.  Carp will not report errors from within these packages
  16. # either, and will not report calls *to* these packages for carp and
  17. # croak.  They replace $CarpLevel, which is deprecated.    The
  18. # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
  19. # text and function arguments should be formatted when printed.
  20.  
  21. # disable these by default, so they can live w/o require Carp
  22. $CarpInternal{Carp}++;
  23. $CarpInternal{warnings}++;
  24. $Internal{Exporter}++;
  25. $Internal{'Exporter::Heavy'}++;
  26.  
  27. our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose);
  28.  
  29. # XXX longmess_real and shortmess_real should really be merged into
  30. # XXX {long|sort}mess_heavy at some point
  31.  
  32. sub  longmess_real {
  33.     # Icky backwards compatibility wrapper. :-(
  34.     #
  35.     # The story is that the original implementation hard-coded the
  36.     # number of call levels to go back, so calls to longmess were off
  37.     # by one.  Other code began calling longmess and expecting this
  38.     # behaviour, so the replacement has to emulate that behaviour.
  39.     my $call_pack = caller();
  40.     if ($Internal{$call_pack} or $CarpInternal{$call_pack}) {
  41.       return longmess_heavy(@_);
  42.     }
  43.     else {
  44.       local $CarpLevel = $CarpLevel + 1;
  45.       return longmess_heavy(@_);
  46.     }
  47. };
  48.  
  49. sub shortmess_real {
  50.     # Icky backwards compatibility wrapper. :-(
  51.     local @CARP_NOT = caller();
  52.     shortmess_heavy(@_);
  53. };
  54.  
  55. # replace the two hooks added by Carp
  56.  
  57. # aliasing the whole glob rather than just the CV slot avoids 'redefined'
  58. # warnings, even in the presence of perl -W (as used by lib/warnings.t !)
  59. # However it has the potential to create infinite loops, if somehow Carp
  60. # is forcibly reloaded, but $INC{"Carp/Heavy.pm"} remains true.
  61. # Hence the extra hack of deleting the previous typeglob first.
  62.  
  63. delete $Carp::{shortmess_jmp};
  64. delete $Carp::{longmess_jmp};
  65. *longmess_jmp  = *longmess_real;
  66. *shortmess_jmp = *shortmess_real;
  67.  
  68. sub caller_info {
  69.   my $i = shift(@_) + 1;
  70.   package DB;
  71.   my %call_info;
  72.   @call_info{
  73.     qw(pack file line sub has_args wantarray evaltext is_require)
  74.   } = caller($i);
  75.   
  76.   unless (defined $call_info{pack}) {
  77.     return ();
  78.   }
  79.  
  80.   my $sub_name = Carp::get_subname(\%call_info);
  81.   if ($call_info{has_args}) {
  82.     my @args = map {Carp::format_arg($_)} @DB::args;
  83.     if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
  84.       $#args = $MaxArgNums;
  85.       push @args, '...';
  86.     }
  87.     # Push the args onto the subroutine
  88.     $sub_name .= '(' . join (', ', @args) . ')';
  89.   }
  90.   $call_info{sub_name} = $sub_name;
  91.   return wantarray() ? %call_info : \%call_info;
  92. }
  93.  
  94. # Transform an argument to a function into a string.
  95. sub format_arg {
  96.   my $arg = shift;
  97.   if (ref($arg)) {
  98.       $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
  99.   }
  100.   if (defined($arg)) {
  101.       $arg =~ s/'/\\'/g;
  102.       $arg = str_len_trim($arg, $MaxArgLen);
  103.   
  104.       # Quote it?
  105.       $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
  106.   } else {
  107.       $arg = 'undef';
  108.   }
  109.  
  110.   # The following handling of "control chars" is direct from
  111.   # the original code - it is broken on Unicode though.
  112.   # Suggestions?
  113.   utf8::is_utf8($arg)
  114.     or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
  115.   return $arg;
  116. }
  117.  
  118. # Takes an inheritance cache and a package and returns
  119. # an anon hash of known inheritances and anon array of
  120. # inheritances which consequences have not been figured
  121. # for.
  122. sub get_status {
  123.     my $cache = shift;
  124.     my $pkg = shift;
  125.     $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]];
  126.     return @{$cache->{$pkg}};
  127. }
  128.  
  129. # Takes the info from caller() and figures out the name of
  130. # the sub/require/eval
  131. sub get_subname {
  132.   my $info = shift;
  133.   if (defined($info->{evaltext})) {
  134.     my $eval = $info->{evaltext};
  135.     if ($info->{is_require}) {
  136.       return "require $eval";
  137.     }
  138.     else {
  139.       $eval =~ s/([\\\'])/\\$1/g;
  140.       return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'";
  141.     }
  142.   }
  143.  
  144.   return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub};
  145. }
  146.  
  147. # Figures out what call (from the point of view of the caller)
  148. # the long error backtrace should start at.
  149. sub long_error_loc {
  150.   my $i;
  151.   my $lvl = $CarpLevel;
  152.   {
  153.     my $pkg = caller(++$i);
  154.     unless(defined($pkg)) {
  155.       # This *shouldn't* happen.
  156.       if (%Internal) {
  157.         local %Internal;
  158.         $i = long_error_loc();
  159.         last;
  160.       }
  161.       else {
  162.         # OK, now I am irritated.
  163.         return 2;
  164.       }
  165.     }
  166.     redo if $CarpInternal{$pkg};
  167.     redo unless 0 > --$lvl;
  168.     redo if $Internal{$pkg};
  169.   }
  170.   return $i - 1;
  171. }
  172.  
  173. sub longmess_heavy {
  174.   return @_ if ref($_[0]); # don't break references as exceptions
  175.   my $i = long_error_loc();
  176.   return ret_backtrace($i, @_);
  177. }
  178.  
  179. # Returns a full stack backtrace starting from where it is
  180. # told.
  181. sub ret_backtrace {
  182.   my ($i, @error) = @_;
  183.   my $mess;
  184.   my $err = join '', @error;
  185.   $i++;
  186.  
  187.   my $tid_msg = '';
  188.   if (defined &threads::tid) {
  189.     my $tid = threads->tid;
  190.     $tid_msg = " thread $tid" if $tid;
  191.   }
  192.  
  193.   my %i = caller_info($i);
  194.   $mess = "$err at $i{file} line $i{line}$tid_msg\n";
  195.  
  196.   while (my %i = caller_info(++$i)) {
  197.       $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
  198.   }
  199.   
  200.   return $mess;
  201. }
  202.  
  203. sub ret_summary {
  204.   my ($i, @error) = @_;
  205.   my $err = join '', @error;
  206.   $i++;
  207.  
  208.   my $tid_msg = '';
  209.   if (defined &threads::tid) {
  210.     my $tid = threads->tid;
  211.     $tid_msg = " thread $tid" if $tid;
  212.   }
  213.  
  214.   my %i = caller_info($i);
  215.   return "$err at $i{file} line $i{line}$tid_msg\n";
  216. }
  217.  
  218. sub short_error_loc {
  219.   # You have to create your (hash)ref out here, rather than defaulting it
  220.   # inside trusts *on a lexical*, as you want it to persist across calls.
  221.   # (You can default it on $_[2], but that gets messy)
  222.   my $cache = {};
  223.   my $i = 1;
  224.   my $lvl = $CarpLevel;
  225.   {
  226.     my $called = caller($i++);
  227.     my $caller = caller($i);
  228.  
  229.     return 0 unless defined($caller); # What happened?
  230.     redo if $Internal{$caller};
  231.     redo if $CarpInternal{$caller};
  232.     redo if $CarpInternal{$called};
  233.     redo if trusts($called, $caller, $cache);
  234.     redo if trusts($caller, $called, $cache);
  235.     redo unless 0 > --$lvl;
  236.   }
  237.   return $i - 1;
  238. }
  239.  
  240. sub shortmess_heavy {
  241.   return longmess_heavy(@_) if $Verbose;
  242.   return @_ if ref($_[0]); # don't break references as exceptions
  243.   my $i = short_error_loc();
  244.   if ($i) {
  245.     ret_summary($i, @_);
  246.   }
  247.   else {
  248.     longmess_heavy(@_);
  249.   }
  250. }
  251.  
  252. # If a string is too long, trims it with ...
  253. sub str_len_trim {
  254.   my $str = shift;
  255.   my $max = shift || 0;
  256.   if (2 < $max and $max < length($str)) {
  257.     substr($str, $max - 3) = '...';
  258.   }
  259.   return $str;
  260. }
  261.  
  262. # Takes two packages and an optional cache.  Says whether the
  263. # first inherits from the second.
  264. #
  265. # Recursive versions of this have to work to avoid certain
  266. # possible endless loops, and when following long chains of
  267. # inheritance are less efficient.
  268. sub trusts {
  269.     my $child = shift;
  270.     my $parent = shift;
  271.     my $cache = shift;
  272.     my ($known, $partial) = get_status($cache, $child);
  273.     # Figure out consequences until we have an answer
  274.     while (@$partial and not exists $known->{$parent}) {
  275.         my $anc = shift @$partial;
  276.         next if exists $known->{$anc};
  277.         $known->{$anc}++;
  278.         my ($anc_knows, $anc_partial) = get_status($cache, $anc);
  279.         my @found = keys %$anc_knows;
  280.         @$known{@found} = ();
  281.         push @$partial, @$anc_partial;
  282.     }
  283.     return exists $known->{$parent};
  284. }
  285.  
  286. # Takes a package and gives a list of those trusted directly
  287. sub trusts_directly {
  288.     my $class = shift;
  289.     no strict 'refs';
  290.     no warnings 'once'; 
  291.     return @{"$class\::CARP_NOT"}
  292.       ? @{"$class\::CARP_NOT"}
  293.       : @{"$class\::ISA"};
  294. }
  295.  
  296. 1;
  297.  
  298.